MacWorld 1999 July

home *** CD-ROM | disk | FTP | other *** search

/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops ƒ / zClass < prev next >

Wrap

Text File | 1999-01-23 | 69KB | 2,873 lines

(* file zClass This file is part of the PPC version of the high-level class/object implementation. It's a "z" file - it's not target compiled, but is loaded on the PPC itself. Some of the PPC class-related code is target compiled in qpClass, since we need it while we're still target compiling. Originaly I wanted to get ALL the class implementation into qpClass, but this proved to bristle with intractible problems, so here we include everything that didn't make it, which is quite a lot! *) \ Note: for all the class/object formats, see cg1. 34 constant IFA_offset : ]C true -> cstate ; immediate : C[ false -> cstate ; immediate \ these are defined in qpClass: \ 0 value PUB/PRIV \ -1 private, 1 public, 0 default - for ivars and methods \ false value STATIC? \ true if following ivars are to be static \ 0 value ^COMP_CLASS \ addr of the class we're currently compiling \ 0 value PIVAR \ hashed name of any public ivar we're accessing \ 0 value PIVSEL \ hashed selector of any msg being sent to \ to a public ivar \ 0 value NEWOBJECT \ addr of object being created \ 0 value #SUP \ number of superclasses for current class \ 0 value SUPERS_TO_SKIP \ 0 value INITID 0 value thisM 0 value superM 0 value tempObjs \ gets addr of class Dummy which we use for temp objects false value bind_to_reg? false value register_request? 0 value reg_for_bind 0 value regcode_for_bind 0 value #PL4temps 0 value #FPL4temps 0 value #VL4temps \ =============================== \ UTILITY WORDS \ =============================== : PRIVATE -1 -> pub/priv ; \ following methods and ivars will be private : PUBLIC 1 -> pub/priv ; \ following methods and ivars will be public : END_PRIVATE 0 -> pub/priv ; \ back to the default : END_PUBLIC 0 -> pub/priv ; \ ditto \ TOfind looks for a temp (local) object. : TOfind { str-addr -- ^ivar offs T | -- str-addr F } str-addr tempObjs? NIF false EXIT THEN \ out if no temp objects hash tempObjs <findIV> IF \ ( -- ^ivar offs xdispl-offs ) drop \ xdispl-offs must be zero for class Dummy dup $ FFFE >= IF \ self or super - mustn't match these in class Dummy! 2drop str-addr false EXIT THEN true ELSE str-addr false THEN ; (* LocFind will be called from Ufind, which is the vector that gets first shot at recognizing a word. It looks at all the possibilities involving local names, which are not in the regular dictionary. These possibilities are: named parms/locals, local objects, and if a class is being compiled, ivars of this class. In the latter case, we arrange for the ivar's address to be pushed at run time simply by compiling ^base followed by an add of the ivar's offset - our code generation will produce optimal code for this. We then have to return the xt of some word to keep FIND happy - we don't need to compile anything else, so we use the xt of NULL and return a 1 instead of True - this makes FIND think it's immediate. So NULL is executed immediately, which does precisely nothing. The one exception to this is if the "ivar" turns out to be SELF or SUPER - in this case we need to call the nucleus word SELF which works out the right base address (this is what happened pre-2.5). Here we keep FIND happy by pushing the xt of SELF and True, so that it sees we've found SELF. *) : LocFind { str-addr \ flags reg# -- cfa T | -- str-addr F } str-addr Pfind ?dup ?EXIT \ Found a named parm/local TOfind IF \ Found temp obj swap iffa w@ -> flags flags 4 >> $ F and ?dup IF \ it's in a register ( offs regcode ) nip ( regcode ) flags 8 >> $ 1F and ( reg# ) reg_name ELSE postpone locReg postpone literal postpone + THEN ['] null 1 EXIT THEN \ Now we look for an ivar name cstate NIF false EXIT THEN \ search fails if we're not compiling \ a class dup hash ^comp_class IFA_offset false (findM) IF \ Found ivar nip nip \ don't need embedded obj offs or \ string addr 12 + w@ \ ivar offset dup $ FFFE >= \ is it SELF or SUPER (just used in \ isolation)? IF drop " (^base) 4- dup w@x + 8 +" evaluate \ i.e. SELF - but I can't evaluate \ that, or we'll end up here again \ and infinitely recurse! ELSE postpone (^base) postpone literal postpone + THEN ['] null 1 ELSE false THEN ; \ 0 -> quitvec 0 -> abortvec 0 -> objInit \ clear vectors \ ' pfind -> ufind \ in qpClass \ : ?CLASS \ Error if not compiling a class definition. \ cstate 0= ?error 115 ; \ ======================== \ BINDING \ ======================== 0 value OBJ_BASE 0 value OBJ_DISPL 0 value OBJ_LOCAL_DISPL 0 value OBJ_IND false value SELF? (* Note: obj_ind, which we use in 68k Mops, isn't needed on the PPC. we don't now use an indirect count in an OD, but just do repeated fetches to different registers till we come to the data we want. On the 68k, as far as I can tell, the only time obj_ind wasn't zero was when we did an early bind to an addr on the stack, or to an objPtr (which used the same code). This was also the reason we kept two offsets - obj_displ and obj_local_displ. Obj_displ applied before any indirection steps, and obj_local_displ after. On the PPC we were able to get rid of these complexities. *) : (OBJ) \ Called from within an inline method. Passes the object's \ base and displacement to Handlers to generate the correct \ address. Optimization will then apply. bind_to_reg? IF regcode_for_bind reg_for_bind reg_name EXIT ELSE obj_base obj_displ obj_ind genaddr obj_local_displ postpone literal postpone + THEN ; : (IX) (* Called from within an inline method. Compiles code to generate the indexed address. ^comp_class has been set by inl_bind to the class of the obj we're binding to. One tricky point is that to access the indexed area, we have to use the dlen value in this class, not the class of the method we're calling (which may be a superclass). But the obj_local_displ has already had the embedded object offset added in (if any). We have to ignore this, since we're using the object's class, not the method's. When the method was found, the value emb_obj_offs was set to this offset, so we subtract it here. *) ^comp_class dlen&xwid swap self? IF drop -1 ELSE #off-align 6 + THEN obj_base obj_displ obj_local_displ emb_obj_offs - obj_ind ^comp_class ffa w@ genxaddr ; : ^BASE compinline? IF (obj) ELSE postpone (^base) THEN ; immediate : ^ELEM compinline? IF (ix) ELSE " (^elem)" evaluate \ need PPC version THEN ; immediate : OBJ postpone ^base ; immediate \ for backward compatibility : IX postpone ^elem ; immediate \ ditto forward enter_meth_in_mod local EARLY_BIND { oCfa oBase oDispl oLDispl oind slf? \ ^mod ptr -- } : INL_BIND \ ( -- b ) ^comp_class cstate self? \ Save over upcoming evaluate slf? NIF objClass -> ^comp_class THEN \ Set ^comp_class and cstate true -> cstate \ so ivars are accessible slf? -> self? oCfa inline_h \ calls evaluate -> self? -> cstate -> ^comp_class \ Restore ; : MODULE_BIND heldMod dup @ @ \ get mod handle and dereference - addr of mod start -> ^mod ^mod 8 + -> ptr \ self-rel addr of exports table ptr @ ++> ptr \ ptr -> start of table 0 -> methIndex BEGIN ptr @ dup 0< IF \ we have a problem - we didn't find the entry in the \ module's export table, though it ought to be there! \ Maybe heldMod should have been zero, and we shouldn't \ have been trying to do a module bind at all?? cr cr ." heldMod " heldMod .h cr cr heldMod 32 - 64 dump 198 die \ "internal error" THEN ^mod + oCfa = NWHILE 4 ++> methIndex 4 ++> ptr REPEAT \ methIndex now has the export table offset for the method. (obj) \ compile push of obj addr (clears heldMod!) ( heldMod ) lit_addr \ and a push of the module's addr methIndex postpone literal \ and a push of export table offset ['] enter_meth_in_mod call_h ; : NORM_BIND heldMod IF module_bind ELSE oCfa (obj) call_h \ call_h will see by the handler code THEN \ that this is a method, and do the ; \ right things, hopefully :loc EARLY_BIND \ { oCfa oBase oDispl oLDispl oind slf? -- } obj_base obj_displ obj_local_displ obj_ind \ Save oBase -> obj_base oDispl -> obj_displ OLdispl -> obj_local_displ oind -> obj_ind oCfa 2- w@ $ BD40 = IF inl_bind ELSE bind_to_reg? IF false -> bind_to_reg? 158 die \ "You can only use inline methods with a register object" THEN norm_bind THEN -> obj_ind -> obj_local_displ -> obj_displ -> obj_base \ Restore ;loc : BIND_TO_OBJ { cfa ^obj offs -- } cfa -1 \ -1 as "base" signals handlers to generate ^obj \ a normal dic addr. We still carry the \ offs here since if we need to access the \ indexed area, we want the original obj addr, \ not some embedded object. offs 0 false early_bind ; : BIND_TO_STK { xt \ svHeldMod -- } heldMod -> svHeldMod 0 -> heldMod xt hStkObj \ ( -- xt base displ ) svHeldMod -> heldMod 0 0 false early_bind ; : BIND_TO_IVAR { cfa offs -- } cfa obj_base obj_displ obj_local_displ offs + obj_ind false early_bind ; : BIND_TO_TMPOBJ { cfa offs -- } cfa <'> locReg 3+ c@ \ current locReg number offs 0 0 false early_bind ; : BIND_TO_REG { cfa -- } true -> bind_to_reg? cfa 0 0 0 0 false early_bind false -> bind_to_reg? ; : BIND_TO_SELF { cfa offs -- } cfa obj_base obj_displ offs obj_ind true early_bind ; \ ============================ \ :CLASS etc. \ ============================ (* Here we set up some quantities so that we can send messages to SELF or SUPER. These are treated syntactically as ivars, so to implement them we actually set up dummy ivars SELF and SUPER. When we're processing a :CLASS definition, we plug the appropriate addresses into these ivars. ^SELF is a word defined to return the addr of the dummy ivar SELF, so we can do the plugging. In the case of SUPER, there may be several superclasses, so we have to go through a class descriptor, since that's the only place we look for an n-way (a set of addresses). So we set the "class" of SUPER to a dummy class SUPCL, which has no ivars or methods (so the search will pass right on by), and plug the superclass pointer of SUPCL to point to the current n-way for the superclasses of the class we're defining. *) \ : ^SELF self_vbl displace ; : :CLASS ?exec header $ BC1D codeW, CDP -> ^comp_class 0 -> pub/priv 0 -> #1st 0 -> #last false -> rec? false -> union? false -> static? 307 ; immediate : MERGE_INFO { ^sup ivlen \ ^wid wid prevWid -- dlen } ^sup dlen&xwid -> wid \ indexed width of this superclass ^sup ffa 1+ c@ 5 and \ Merge "large" and "general" flags with ^comp_class ffa 1+ cset \ what we have already wid 0EXIT \ If this superclass not indexed, we're done \ This class is indexed - we need to check if prev classes were indexed \ and make sure the widths are compatible. ^comp_class dfa 2+ -> ^wid \ Addr of wid field in class we're building ^wid w@ -> prevWid \ Get previous width wid 32760 u> \ "indexed width" of 32766/7 really means IF \ obj_array. prevWid \ In this case if we already have a width, IF prevWid -> wid \ we use that, ELSE wid ivlen -> wid \ otherwise current ivar len becomes the width. ( old wid ) 32766 = IF \ large_obj_array - mark boundary between ivars \ we are/aren't mapping to the indexed area ivlen aligned ^comp_class xoffa w! wid aligned 4+ -> wid \ and allow for ^class offset \ and indexed area offset \ before each element THEN THEN THEN prevWid NIF wid ^wid w! \ If no prev width, set width & we're done ELSE prevWid wid <> ?error 88 \ "Incompatible indexed widths" THEN ; local (SUP) { \ ^supcl ivlen ^nway ^sup ^newClass thisLen -- } : NEXT_SUPER ( cfa -- ) chkClass -> ^sup ^sup relocCode, \ Add ^class to n-way ^sup ivlen merge_info -> thisLen #sup IF \ If this is a subsequent class, ivlen #align4 4+ -> ivlen \ align and allow for ^class offset and \ 2 extra bytes padding THEN thisLen ++> ivlen \ And add ivar length of new class 1 ++> #sup ; : SUPERS_LOOP BEGIN \ Loop over superclasses: ' \ cfa of next item on list }or)? IF drop EXIT THEN ( cfa ) next_super \ handle next superclass \ 1super? ?EXIT \ Yerk has only one superclass AGAIN ; :loc (SUP) 307 ?pairs \ Make sure we're in the right place CDP -> ^newClass 46 ( classSize ) code_reserve \ Space for class record CDP -> ^nway \ n-way for superclasses will 0 -> ivlen 0 -> #sup \ start here ^newClass 2+ 32 bounds DO ^nway i displ! 4 +LOOP \ point methods links to nway ^nway ^newClass IFA displ! \ and ivars link false -> relocChk? supers_loop \ Loop over superclasses 0 code, \ Terminate n-way " SUPCL" sFind drop -> ^supcl ^supcl 2+ 32 bounds DO ^nway i displ! 4 +LOOP \ we point the method and ivar links ^nway \ in supcl to the n-way ^supcl IFA displ! ^comp_class xoffa w@ " SUPCL" sFind drop xoffa w! \ and set xoffs in supCl ivlen ^comp_class dfa w! \ Set total ivar length \ ^comp_class ^self 8 + reloc! \ Store ^class in SELF true -> relocChk? postpone ]c \ In a class definition 308 ;loc : SUPER{ ( false -> 1super? ) (sup) ; immediate \ : SUPER( postpone super{ ; immediate \ : <SUPER true -> 1super? (sup) ; immediate \ For compatibility with Yerk -- only looks for 1 superclass : (;CL) postpone [ postpone c[ ; : ;CLASS (;cl) 308 ?defn ; immediate 1 value DFRSELID \ 1 means no late bind going on - otherwise it's \ the selector we're late binding with true value SLCTRS? \ Set false to treat selectors as normal words \ for full ANSI compatibility : SEL? \ ( addr -- addr b ) True if word at addr is a selector xxx: slctrs? NIF false EXIT THEN dup count tuck 1- + c@ & : = swap 1 > and ; : GETSELECT \ Gets a selector from the input stream mword sel? not ?error 124 hash 1 -> dfrSelID ; ' null vect GET1ST&LAST ' null vect DoCall1ST ' null vect DoCallLast : M_HEADER { selID -- } \ Builds a method header and entry sequence. \ Note: also called from the assembler. selID ^comp_class MFA selID hashed-hdr \ Build header drop \ drop extra selID (needed by MFA) CDP 4- -> ^meth_link pub/priv -1 = 1 and codeW, \ public/private flag (default is public) 0 codeW, \ padding for alignment $ BE400000 code, \ "handler code" for PPC methods, \ and initial flag bytes CDP 2- -> thisM \ Remember method cfa ; \ 0 codeW, \ space for parm flags (or do it in Mentry?) \ Mentry ; \ Compile the entry sequence : :M { \ selID -- } \ Starts compiling a method. CDP -> last_colon_defn \ used by compile_call in checking where \ a call is coming from true -> method? ?class rec? ?error 191 \ unmatched '{' in ivar list 0 -> superM getSelect -> selID 10 -> cstate \ Means we've read :m, no call_1st yet selID ^comp_class MFA_offset true (findm) \ is method already defined? IF -> superM \ warnings? \ IF cr CDP count type type# 182 \ "Method redefined" \ THEN heldMod NIF superM ^comp_class > ?error 183 THEN \ - but if in same class, error drop THEN get1st&last \ ?unHoldMod CDP -> const_data_start selID m_header \ Build method header #1st #last + IF $ 80 thisM 5 - cset THEN \ set call1st/callLast flag obj_base_reg -> obj_base \ gpr20 0 -> obj_displ \ For any inline method calls false ppc_entry \ Start to compile the method drop 305 \ change security marker to say method doCall1st \ Compile any Call1st calls first ; immediate : ;M true -> method? \ things might have happened during the defn \ to make it false, like compilation being \ turned off and on. This doesn't matter, \ but we definitely need it true here. #last IF doCallLast THEN curr-def 2- (;) 0 -> #1st 0 -> #last 305 ?defn ; immediate \ ============== Local sections for methods ============== \ These function just like regular local sections. The implementation \ is nearly the same. 0 value mloc_addr : MLOCAL \ Starts a local section for methods local? ?error 93 1 -> local? \ We change it to the normal -1 \ as soon as "{" is read. true -> localSect? CDP -> CD_gpr_loc postpone :m drop postpone [ CDP -> mloc_addr $ 48000000 code, \ uncond branch to be resolved by :mloc private ; : :MLOC public ?loc getSelect drop CDP -> const_data_start $ BE030000 code, \ marks this as the :mloc position \ (just for disassembly) true -> method? false -> local? \ so entry sequence gets compiled true -> mloc? \ so const data gets handled properly false ppc_entry \ handle ppc proc entry drop 309 \ security marker for :mloc curr-def mloc_addr -> curr-def PLentry -> curr-def tempObjs? IF initTemps THEN ; immediate : ;MLOC 309 ?defn false -> leaf? \ let's just reduce the bug possibilities! #last IF doCallLast THEN mloc_addr 2- (;) \ #last IF true -> method? doCallLast ( defnEnd) false -> method? THEN 0 -> #1st 0 -> #last curr-def mloc_addr - \ resolve the forward branch from MLOCAL mloc_addr +! false -> localSect? ; immediate \ ================ INDEXED, GENERAL etc. ================= \ These are words which can appear in a class declaration, in the \ position \ :class someClass super{ someSuper } general \ They add attributes to the class. : INDEXED \ ( width -- ) Sets a class and its subclasses to indexed ?class ^comp_class dfa 2+ w! ; : LARGE ; \ in effect, this always applies on the PPC : into_flags { new_flags -- } ?class ^comp_class ffa dup w@ new_flags or swap w! ; : GENERAL (* Sets the "general" option on a class, which will force an ivar of that class to be a general object with a class pointer (so it can be late-bound to) even if it's within a record. Normally you should just not put such ivars in a record, but using GENERAL gives a bit of extra security, for classes for which you know that they will definitely be late-bound to. (An attempt to late-bind to an ivar without a class pointer will give the "not an object" error at run time, which isn't easy to track down.) Note that indexed classes are always general anyway. Also if there's a message sent to [self] somewhere in one of the methods, we know that the class *must* be general, so in this case we simply set the general attribute. *) 4 into_flags ; (* moved to qpClass... : CAN_BE_GPR $ 30 into_flags ; : CAN_BE_FPR $ 40 into_flags ; : CAN_BE_VR $ 50 into_flags ; : ALIGNMENT ( n -- ) 8 << into_flags ; \ n is power of 2 *) \ =========================== \ SELECTORS \ =========================== \ First, here are the special-purpose things which can follow a selector. \ These can't appear in isolation. \ We allow ** and [] as synonyms of [ ] to late-bind to whatever is on the \ stack. Note: [] is used in JForth. \ We also allow [self] as a synonym of [ self ] : ** 83 die ; \ "Has no meaning unless preceded by a selector" : [] 83 die ; : [SELF] 83 die ; : SUPER> 83 die ; : IVAR> 83 die ; : CLASS_AS> 83 die ; : ] hide dfrSelID 1 = IF postpone ] EXIT THEN \ if no late bind, this is a \ standard Forth ] dfrSelID NIF 187 die THEN \ late bound public ivar reference \ not implemented yet! state IF 251 ?pairs dfrSelID postpone literal postpone send ELSE $ deadbeef $ 106 db \ shouldn't happen dfrSelID send THEN 1 -> dfrSelID ; immediate 100 constant pubIvarTyp \ &&& temp false value need_class? false value implicit_late_bind? \ true for pre-2.7 auto-late-bind \ to locals or values (* REFTOKEN ( -- cfa tokenType | -- various type ) is called when we've parsed a selector - it determines the type of the following word. The order of checking determines the priority of names. Up to 2.6 we checked for locals first, but this was a bad idea since a local could have the same name as an object, and implicit late binding to locals was legal. This wouldn't show up until a crash at run time. So now we check for temp objects, then ivars, then locals IF implcit_late_bind? is true. "various" will be the cfa of whatever came after the selector, or ( offset ^ivar ) for ivars and temp objects (which are treated as ivars of the class Dummy). *) : REFTOKEN \ ( -- cfa tokenType | -- various type ) false -> need_class? Mword \ grab next word TOfind IF tmpObjTyp EXIT THEN \ check for temp object IVfind IF ivarTyp EXIT THEN \ check for ivar implicit_late_bind? IF Pfind IF locTyp EXIT THEN \ check for named parm/locals THEN ( here ) dup thread dup @ + (find) 0= ?error 125 dup ['] ** = IF lbTyp EXIT THEN dup ['] [] = IF lbTyp EXIT THEN dup ['] [ = IF bktTyp EXIT THEN dup ['] [self] = IF lbSelfTyp EXIT THEN dup ['] super> = IF superTyp EXIT THEN dup ['] ivar> = IF pubIvarTyp EXIT THEN dup ['] class_as> = IF true -> need_class? classTyp EXIT THEN dup hdlr CASE $ BC0B OF >obj objTyp ENDOF $ BC1D OF classTyp ENDOF $ BC1F OF objPtrTyp ENDOF $ BC03 OF valTyp ENDOF \ Note: here we can treat vectors as words. 126 die \ "Not an object name" ENDCASE \ but if we got wordTyp or valTyp, it's only legal if implicit_late_bind? \ is true implicit_late_bind? ?EXIT \ all OK - done dup wordTyp = over valTyp = or IF 126 die THEN ; \ These words handle the binding of a selector to whatever follows it. (* FIX_PIVAR does the housekeeping for accessing a public ivar. When we encounter msg: ivar> then we store the selector in pivSel, and the hashed ivar name in pivar. We then continue with a zero "selector", which signals that it's a public ivar access, and leads to us being called back here to fix everything up once we've got the class. *) : FIX_PIVAR { ^class in_class? \ ^ivar offs xdispl-offs -- cfa offs xdispl-offs } ^class ?>classInMod -> ^class pivar ^class <findIV> \ ( ^ivar offs xdispl-offs true OR false ) 0= ?error 192 \ "ivar not found" -> xdispl-offs -> offs -> ^ivar ^ivar iffa w@ \ get ivar flags dup 4 and 0= ?error 193 \ ivar not public 2 and \ static flag in_class? IF 0= ?error 197 \ ivar not static ELSE ?error 195 \ wrong syntax for public static ivar THEN \ now we find the method in the ivar's class pivSel ^ivar ivFindM drop \ %%% don't worry about large_obj_arrays \ which are ivars yet! ( cfa offs-within-ivar ) in_class? IF \ for public static ivars, the "offset" we return is \ actually the ivar's real data address. drop ^ivar static_ivar_offs + @abs -> offs ELSE ++> offs THEN offs xdispl-offs ; \ PUBLIC_STATIC_IVAR_REF handles a message bind to a public static ivar \ (done via the msg: ivar> in_class someClass syntax) : PUBLIC_STATIC_IVAR_REF refToken classTyp <> ?error 196 \ class name must follow in_class true fix_pivar drop \ %%% don't worry about large_obj_arrays \ which are public static ivars yet! 0 bind_to_obj ; \ OBJREF handles a reference to a normal object. : OBJREF { selID ^obj \ cfa offs xdispl-offs -- } selID IF selID ^obj objFindm ELSE \ it's a public ivar reference in the referenced object ^obj >class false fix_pivar THEN ( cfa offs xdispl-offs ) -> xdispl-offs -> offs -> cfa xdispl-offs IF ^obj xdispl-offs + lit_addr " dup @ +" evaluate offs IF \ will normally be zero offs postpone literal " +" evaluate THEN cfa bind_to_stk EXIT THEN cfa ^obj offs bind_to_obj ; \ IVARREF handles a reference to an ivar. : IVARREF { selID ^ivar offs xdispl-offs \ cfa stat? -- } heldMod 0 -> heldMod \ save offs $ FFFE >= -> selfRef? \ if self or super. Allows private \ methods to be found by (findm) selfRef? IF supers_to_skip -> sups2skip \ sups2skip is interrogated by (findm). \ This must only be done if self or \ super is the target. 0 -> offs \ "real" offset is zero ELSE ^ivar iffa w@ 2 and -> stat? \ static ivar? THEN selID IF selID ^ivar ivFindM \ %%% don't worry about large_obj_arrays \ which are ivars yet! selfRef? IF -> xdispl-offs ELSE drop THEN ++> offs \ add embedded obj base offs to ivar offs -> cfa 0 -> sups2skip 0 -> supers_to_skip selfRef? IF xdispl-offs IF xdispl-offs postpone literal " ^base + dup @ +" evaluate cfa bind_to_stk ELSE cfa offs bind_to_self false -> selfRef? THEN \ ?unholdMod -> heldMod EXIT THEN ELSE \ it's a public ivar reference within the referenced ivar ^ivar ^iclass false fix_pivar drop \ %%% don't worry about large_obj_arrays \ which are ivars yet! ++> offs -> cfa THEN stat? IF cfa ^ivar static_ivar_offs + @abs 0 bind_to_obj \ ?unholdMod -> heldMod EXIT THEN xdispl-offs IF xdispl-offs postpone literal " ^base + dup @ +" evaluate offs IF \ will normally be zero offs postpone literal " +" evaluate THEN cfa bind_to_stk ELSE cfa offs bind_to_ivar THEN \ ?unholdMod -> heldMod ; \ OP/CL is common code factored out of objPtrRef and classRef, which \ are very similar. : OP/CL { selID ^class \ cfa offs xdispl-offs -- } selID IF selID ^class clFindm ELSE ^class false fix_pivar THEN -> xdispl-offs -> offs -> cfa xdispl-offs IF xdispl-offs postpone literal " + dup @ +" evaluate THEN heldMod \ save offs postpone literal " +" evaluate -> heldMod \ restore cfa bind_to_stk ; \ OBJPTRREF handles a reference to an object pointer. : OBJPTRREF { selID OP-cfa \ OPclass cfa offs xdispl-offs addr -- } OP-cfa (comp) \ Compile a fetch of the OP-cfa, \ giving ^obj at run time OP-cfa >body -> addr addr 4+ @abs -> OPclass OPclass 0= ?error 86 \ "ObjPtr hasn't had a class specified" OPclass hdlr $ BC2D = IF \ Class is exported OPclass 6 + wdisplace \ Addr of module compmod = ?error 84 \ It's the module we're compiling - \ this is a no-no, since the ObjPtr \ reference will use the OLD module! OPclass ?>classInMod -> OPclass THEN selID OPclass OP/cl ; \ CLASSREF handles a reference to a class - this means use the object \ whose addr is on the stack, but ASSUME it is of the given class \ and early bind, without checking. \ The code is very similar to objPtrRef, naturally enough. : CLASSREF { selID ^class \ cfa offs xdispl-offs -- } need_class? IF ' chkClass -> ^class false -> need_class? THEN selID ^class OP/cl ; \ TMPOBJREF handles a reference to a temp object. The temp obj \ is set up as an ivar of class Dummy. : TMPOBJREF { selID ^ivar offs \ svHeldMod cfa xdispl-offs flags reg# -- } heldMod -> svHeldMod 0 -> heldMod selID IF selID ^ivar ivFindM ELSE ^ivar 8 + @abs false fix_pivar THEN -> xdispl-offs ++> offs -> cfa xdispl-offs IF postpone locReg xdispl-offs postpone literal postpone + postpone dup postpone @ postpone + offs IF offs postpone literal postpone + THEN \ will normally be zero cfa bind_to_stk ELSE \ is the temp object in a register? ^ivar iffa w@ -> flags flags 4 >> $ F and ?dup IF \ yes - we set the appropriate reg# \ for the kind of reg we're binding to. -> regcode_for_bind flags 8 >> $ 1F and -> reg_for_bind cfa bind_to_reg ELSE cfa offs bind_to_tmpObj THEN svHeldMod -> heldMod THEN ; \ SuperRef handles the msg: super> someSuper construct. : SUPERREF { selID \ ^nway namedClass ^nway' cnt -- } ?class \ Must be compiling a class ' -> namedClass \ get named class xt ^comp_class sfa -> ^nway ^nway -> ^nway' 0 -> cnt BEGIN ^nway' @ 0= ?error 120 \ "superclass" not found ^nway' @abs namedClass = NWHILE 1cell ++> ^nway' 1 ++> cnt REPEAT cnt -> supers_to_skip selID " SUPCL" sFind drop 46 + \ careful of hard-coded number here $ FFFE 0 ivarRef \ equivalent to msg: super ; forward COMPREF \ PubIvarRef handles the msg: ivar> someIvar IN someObj construct, to \ send a message directly to a public ivar in an object. At this point \ we've just read "ivar>". : PUBIVARREF { selID \ addr len ^class ^ivar -- } selID -> pivSel \ save selID being sent to the ivar mword hash -> pivar \ parse ivar name mword count -> len -> addr addr len " IN" s= IF 0 \ dummy "selID" for compRef (not a legal selector) compRef \ handle whatever object comes after IN. The \ zero selector signals that a public ivar in the \ indicated object is to be accessed - real selectors \ can't ever be zero. This will lead to fix_pivar \ being called to complete the job. ELSE addr len " IN_CLASS" s= IF public_static_ivar_ref ELSE true ?error 194 \ "wrong syntax for public ivar" THEN THEN ; \ LBselfRef handles messages to [self] - i.e. late bound to Self. : LBSELFREF ( selID -- ) " self" evaluate postpone literal \ pushes ^self, then selID postpone send ; \ Now here are the main words which compile the selector bindings. \ CompRef operates at compile time - it compiles a selector bind. :f COMPREF \ ( selID -- ) refToken \ ( selID <various> type ) \ <various> will be the cfa of whatever came after the selector, \ or ( offset ^ivar ) for ivars and temp objects (which are \ treated as ivars of the class Dummy). CASE objTyp OF objRef ENDOF ivarTyp OF ivarRef ENDOF objPtrTyp OF objPtrRef ENDOF tmpObjTyp OF tmpObjRef ENDOF classTyp OF classRef ENDOF \ These next 3 can only come up if implicit_late_bind? is true: \ valTyp OF compdfr ENDOF \ locTyp OF compdfr ENDOF \ wordTyp OF compdfr ENDOF lbTyp OF drop postpone literal postpone send ENDOF lbSelfTyp OF drop LBselfRef ENDOF bktTyp OF drop -> dfrSelID 251 ENDOF superTyp OF drop superRef ENDOF pubIvarTyp OF drop pubIvarRef ENDOF 82 die \ "Selector can't be used on that" ENDCASE ;f (* RunRef is the execution mode equivalent - it executes a selector bind. We do this simply by compiling it in a buffer then executing it there. The code is a bit like EX-GEN (see cg7). While we're compiling in the buffer, we save CDP on the return stack, then restore it before executing what we compiled (since it might do some compiling itself). This isn't long, but it's a bit tricky: *) : runRefBuf ; \ never called, just ticked 256 code_reserve \ allows 4 nested binds - worst case \ 32 bytes each, we hope 0 value bufPtr 0 value hiCDP : RUNREF { selID \ svCDP svBufPtr svState svMC svMD -- } CDP -> svCDP \ save DP CDP hiCDP umax -> hiCDP \ so we can reset CDP to right place on an error bufPtr NIF ['] runRefBuf 2- ELSE bufPtr THEN dup -> CDP -> svBufPtr \ now we'll compile in runRefBuf state -> svState \ save state \ -1 -> state \ need compile state so this compilation works properly :noname drop \ start a noname defn - drop security flag, leave xt selID compRef \ compile the binding 300 postpone ; \ end noname defn, return to interpretation svState -> state \ restore state 0 -> hiCDP \ don't need it any more and could cause problems \ ?unholdMod CDP -> bufPtr \ new bufPtr value \ svBufPtr CDP svBufPtr - fix_caches \ we're about to execute what we just compiled svCDP -> CDP \ restore CDP since the code might compile something modCode -> svMC modData -> svMD compmod IF modcode_comp_start half_displ_range + -> modCode moddata_comp_start half_displ_range + -> modData THEN ( :noname xt ) execute \ execute compiled code svMC -> modCode svMD -> modData \ restore module base addr regs svBufPtr -> bufPtr \ and old bufPtr ; \ ======== Selector support ========= \ MESSAGE is the handling word invoked by using a selector. : MESSAGE immed state IF \ Compile state compRef \ Compile the message send \ ?unHoldMod ELSE runRef \ Run state - execute object/vector reference. \ ?unHoldMod is called by ex-method at the \ end, so we don't need to call it here. THEN ; (* FIND will call the forward-defined initFind first, to attempt to find a name. So here we re-resolve initFind to lump together all the special cases we have to look for after we've parsed an input word, but before we can do a regular dictionary lookup. At present these are selectors, named parms/locals, ivars and local objects. If we invent more later, they can easily be added. If we succeed here, we return the selector ID or zero, the cfa of the handling word, and 1 or -1 (this will cause FIND to exit without doing anything more). If we fail, we return the original string address and false. *) :f initFIND \ ( str-addr -- selID message-cfa T | -- str-addr F ) sel? \ is it a selector? IF hash \ yes - leave selID ['] message 1 \ and cfa of message, and 1 (it's immediate) ELSE LocFind \ no - look for the various kinds of local name THEN ;f \ ' 1stFind -> Ufind : OBJLEN \ ( -- objlen ) Computes total data length of current object. ^base (^dlen) dup w@ swap 2+ w@ ?dup IF idxBase 4- @ 1+ * + 4+ THEN ; \ SET_CLASS should only be used internally in the Mops implementation. It patches \ nucleus objects when their classes are defined in higher-level files. Actually \ it could be used to change the class of any object, but that wouldn't be a very \ clever thing to do. \ Usage: fFcb ['] file set_class : SET_CLASS { ^obj theClass -- } theClass chkClass ^obj 8 - reloc! \ Patch ^class 2 ^obj 2- w! \ Not indexed (yet) -4 ^obj 4- w! ; \ ^class offset : CHKSAME \ ( ^obj -- ^obj ) \ A check that two objects are of exactly the \ same class. dup >classXt ^base >classXt <> ?error 87 ; \ ========= Object pointers ========== (* Object pointers are low-level objects (like VALUEs) which point to a normal (high-level) object, and which allow early-bound messages to be sent to the object by syntactically sending them to the object pointer. The normal syntax is ObjPtr ZZZ class_is someClass Thereafter, any messages sent to zzz are early-bound to the object that zzz points to at the time the message executes. If you need to declare the object pointer before the class exists, use SET_TO_CLASS once the class is defined, thus: :class SOMECLASS super{ object } ' someOP set_to_class someClass etc. *) :f ToObjPtr state IF litAddr_h " (toOP)" evaluate ELSE >body (toOP) THEN ;f \ Note: (toOP) is in qpClass. : CLASS_IS \ ( --< class > ) ?exec ' chkClass DP 4- reloc! ; : SET_TO_CLASS { ^objPtr \ ^cl --< class > } ' -> ^cl ^objPtr hdlr $ BC1F <> ?error 85 \ "That isn't an ObjPtr" \ Now if "class" is an imported word, we change the handler code \ to "imported class". This is normally done when the module \ is compiled, but it may not be yet, since we probably \ want to refer to the ObjPtr in the module. ^cl hdlr $ BD2E = IF $ BC2D ^cl 2- w! ELSE ^cl chkClass drop THEN ^cl ^objPtr >body 4+ reloc! ; \ =================================== \ Bytes is used as the allocation primitive for basic classes : BYTES { numBytes \ svRec? -- } ?class rec? -> svRec? true -> rec? \ Don't want an object header here " object" sFind drop ivDef numBytes ^comp_class dfa w+! svRec? -> rec? ; (* ================ Temp (local) objects =================== Syntax: : aWord { loc1 loc2 -- } \ Locals are optional, of course temp { var v1 int i1 string s } Or you can use temp{ ... } if you prefer. As the syntax is quite similar to a list of ivars of a class, we actually implement the temp objects as though they're the ivars of a dummy class (which we uncreatively call Dummy). This is just a convenience during the compilation of a defn with temp objects. It allows us to define them and keep them visible during the compilation of the definition, while mainly using existing code for ivar access. We don't need these ivar dic entries once the defn is finished, so we actually put them high in the dictionary out of the way of the defn we're compiling. At the end of the defn, we reinitialize Dummy's ivar link ready for next time. *) getSelect release: constant releaseID :class DUMMY super{ object } ;class ' dummy ifa @ constant dummyIfa \ ivar link corresponding to no ivars - it will be a relative \ pointer to the n-way for the superclass, and thus a constant : RESETTEMPS dummyIfa ['] dummy ifa ! 0 ['] dummy dfa ! \ clear dlen and xwid 0 ['] dummy ffa w! \ and flags ; \ Note we don't have to worry about the mfa since Dummy never gets \ its own methods. (* InitTemps is called when we're compiling the prologue for a definition with temp objects. It compiles a call to make_obj for each object, so that they're properly initialized. Note we can't just call make_obj once using class Dummy, since its ivar list is wiped out after each defn with temp objects, so at run time it won't have any! But we don't need Dummy at run time anyway - we only need the "ivars" which are the temp objects themselves. *) :f INITTEMPS { \ infa ^class flags reg# -- } ['] dummy ifa displace -> infa BEGIN infa @ 0< WHILE infa ^iclass -> ^class infa iffa w@ -> flags flags 8 >> $ 1F and dup -> reg# \ register? IF \ yes - we'll just clear the reg. Not quite \ classinit:, but better than nothing. flags 4 >> $ F and CASE 3 OF \ $ 38000000 reg# 21 << or ENDOF \ rn 0 li, 0 reg# lit>this_GPR ENDOF 4 OF $ FC007090 reg# 21 << or code, \ frn fr14 fmr, reg# mark_fpr_initialized ENDOF 5 OF \ vec reg - we use vspltisw to splat zero $ 10000000 908 or reg# 21 << or code, ENDOF ENDCASE ELSE ^class xwid IF \ it's indexed - we'll have #elements on the stack, \ so we need to compile it as a literal for \ make_obj to grab at run time. infa i#els postpone literal THEN ^class lit_addr infa ioffs postpone literal postpone locreg postpone + postpone make_obj THEN infa ^nextivar -> infa REPEAT ;f (* ReleaseTemps is called from (;) in cg5 at the end of a definition. It compiles a release: xxx for all temp objects. Because of the way we've defined release: in class Object, for simple objects no code will actually be generated. Note we mustn't call resetTemps here since this might be an EXIT, not the final semicolon. We leave calling resetTemps till a new temp{ comes up. *) :f RELEASETEMPS { \ infa -- } ['] dummy ifa displace -> infa BEGIN infa @ 0< WHILE infa ^iclass 0EXIT \ shouldn't happen, actually releaseID infa ivFindM 2drop infa ioffs bind_to_tmpObj \ compile release: infa ^nextivar -> infa REPEAT ;f : }TEMP 130 ?pairs ['] } >body ! \ restore old action for "}" -> ^comp_class -> cstate -> curr-def -> CDP \ restore other things postpone ] \ start compiling 0 -> basic_block_start 0 -> backstop_CDP tempObjs dlen -> tempObj_block_size \ for cg3, so it will compile \ the right prolog true -> tempObjs? ['] dummy ffa w@ 8 >> $ F and -> xalignment \ set any extra alignment we need for the frame local? NIF \ set up for entry unless we're in a local \ section (then it gets done by :LOC) PLentry <'> locreg 3+ c@ mark_gpr_initialized \ need to do this before we use it - which \ initTemps does! initTemps THEN ['] releaseTemps -> releaseTemps_xt \ (;) compiles a call to there at semicolon time #PL4temps -> #PL #FPL4temps -> #FPL #VL4temps -> #VL ; : TEMP{ immed (* First we have to allocate an internal local variable as a frame pointer. There are 4 situations. There may or may not already be locals, and we may or may not be in a local section. Note we can be in a local section even if there aren't already locals, since the purpose of the local section might be just to establish a section for these temp objects. If there are already locals, we just add another. If we're not in a local section we need to recompile the entry sequence (done by PLentry) since the number of regs to be saved and set up is different. But if we're in a local section, we don't have to recompile since we haven't called PLentry yet, so we just add the extra local. If there aren't any locals already, we just call initLocs which sets them up, before adding the new one. *) resetTemps #PL #FPL or NIF initLocs THEN \ No locs before, so weset up for them now #PL -> #PL4temps \ We use these local copies since having #FPL -> #FPL4temps \ compilation turned off and on clobbers \ #PL and #FPL false -> leaf? \ Our temp object frame stuff is quite \ complicated, so we don't try to do leaf \ optimization which wouldn't be worth it \ anyway. local? IF -1 -> local? THEN \ If in a local section, setting local? \ to -1 means we've defined the locals \ so can't do it again true -> locFlg \ it's a local, not a parm " x " pad place pad addToParmList \ pseudo local variable - name has \ a space so can't conflict 32 #PL - \ this is the GPR# for the frame pointer dup -> TO_gpr# \ save it <'> locReg 3+ c! \ and plug into locReg dic entry so \ it identifies itself as the right reg (* Next we save CDP and move a long way up in the free dic space - we'll put the "ivar dic entries" for the temp objs there - we don't need them after the defn is compiled. *) CDP $ 2000 ++> CDP code_align curr-def cstate true -> cstate ^comp_class ['] } >body @ \ save old action for "}" ['] }temp -> } \ "}" will now be same as }temp 130 \ for ?pairs ['] dummy dup -> ^comp_class \ local objs will look like ivars of Dummy -> tempObjs \ this will enable finding them postpone [ \ stop compiling ; : TEMP gobble{ postpone temp{ ; immediate \ set_CD_gpr# sets the GPR we're going to use for this definition to \ point to the start of the constant data. We make it an internal \ local variable, so the code is very similar to TEMP{ above. :f set_CD_gpr# CD_gpr# ?EXIT \ out if we've already done it #PL #FPL or NIF initLocs THEN \ No locs before, so set up for them now local? IF -1 -> local? THEN \ If in a local section, setting local? \ to -1 means we've defined the locals \ so can't do it again true -> locFlg \ it's a local, not a parm " q " pad place pad addToParmList \ pseudo local variable - name has \ a space so can't conflict 32 #PL - \ this is the GPR# for the const data pointer dup -> CD_gpr# select: GPRs permanent: GPRs #PL -> #PL4temps \ may be needed for register temp objects ;f \ ================= register temp objects ==================== (* A temp object can be specified to be instantiated in a register if possible, by putting "register" before its declaration (a bit like C). Any methods called on a register temp object must be inline, which makes sense, since non-inline methods need the address of the object in the obj base register (r20), and objects in a register don't have an address! Also, of course, the object must have a length less than or equal to that of the register. If we can't meet a register request, that isn't necessarily an error. A user might optimistically put "register" on an object whose class can't go in a register, or we might just not have enough registers, but as that doesn't affect the results, we don't call it an error. But if the object is indexed, or bigger than the register, that's probably a Mops bug since we should never use can_be_gpr etc. on those classes. Or maybe the user has wrongly used can_be_gpr. So we give an error for those. *) : REGISTER cstate NIF 222 die THEN \ "A register object must be a temp object" true -> register_request? ; :f REGISTER_CHECK { ^class ivflags \ regcode ivLength -- ivflags' } register_request? NIF ivflags EXIT THEN false -> register_request? \ for next time ^class ffa w@ 4 >> $ F and -> regcode regcode NIF ivflags EXIT THEN \ that class doesn't have can_be_gpr \ or whatever specified. We don't \ call this an error. ^class dlen&xwid IF 223 die THEN \ "indexed object can't be in a register" regcode CASE 3 OF \ check if we can get a gpr 4 > IF 224 die THEN #PL4temps maxPL < IF 1 ++> #PL4temps 32 #PL4temps - \ this is the GPR# 4 << 3 or 4 << or> ivflags THEN ENDOF 4 OF \ check if we can get an fpr 8 > IF 224 die THEN #FPL4temps maxFPL < IF 1 ++> #FPL4temps 32 #FPL4temps - 4 << 4 or 4 << or> ivflags THEN ENDOF 5 OF \ check if we can get a vr 16 > IF 224 die THEN #VL4temps maxVL < IF 1 ++> #VL4temps 32 #VL4temps - 4 << 5 or 4 << or> ivflags THEN ENDOF ENDCASE ivflags ;f (* *** \ testing temp objects with indexing: +echo : q temp{ 10 array aa 5 array bb } 5 at: aa 4 to: bb ; : qq db q ; endload *) (* ================= Records and unions ==================== Syntax: record <name> \ The name is optional { var v1 int i1 string s } union <name> \ The name is optional { var v1 int i1 string s } Or you can use record{ ... } or union{ ... } if you prefer, if it's unnamed. The similarity of syntax to temp objects is quite deliberate. But any similarity to Your Favorite Language is entirely accidental. Well actually it's not, but I think this syntax is as good as any, and probably more readable for folks coming from the land of C. unions can be nested within records and vice versa. NOTE: it's best to not use unions unless you're really sure you know what you're doing. Having different objects sharing the same memory is sure to cause problems if you're careless! *) : SVREC ^comp_class dfa w@ rec? union? unionOffs 68k_align? ; : RSTREC -> 68k_align? -> unionOffs -> union? -> rec? union? IF \ we fell back in a union, so we \ reset data pointer to where it was at the beginning \ of this union/rec ^comp_class dfa w! ELSE drop THEN ; : ?HANDLE_NAME { \ sv_>in sv_^class sv_rec? -- } >in @ -> sv_>in ^comp_class -> sv_^class rec? -> sv_rec? Mword count " {" s= NIF \ we've got a name for the record true -> rec? \ must do this before defining the name "object" sv_>in >in ! " object" sFind drop ivDef sv_rec? -> rec? sv_^class -> ^comp_class gobble{ \ "{" must follow THEN ; : }RECORD 131 ?pairs rstRec ['] } >body ! ; : RECORD{ ?class \ must be compiling a class ['] } >body @ \ save old action for "}" ['] }record -> } \ "}" will now be same as }record svRec \ save parameters for any existing record/union 131 \ for ?pairs true -> rec? false -> union? ; : RECORD ?handle_name record{ ; : 68k_RECORD{ record{ true -> 68k_align? ; : 68k_RECORD record true -> 68k_align? ; : }UNION 132 ?pairs unionOffs ^comp_class dfa w! rstRec ['] } >body ! ; \ restore old action for "}" : UNION{ ?class \ must be compiling a class ['] } >body @ \ save old action for "}" ['] }union -> } \ "}" will now be same as }union svRec \ save record/union parameters 132 \ for ?pairs true -> rec? true -> union? ^comp_class dfa w@ -> unionOffs ; : UNION ?handle_name union{ ; (* ================= Static ivars ==================== Syntax: static { var v1 int i1 string s } Or you can use static{ ... } if you prefer. These are like static class variables in C++ - they belong to the class, not the object, and thus are shared by all objects of the class. We allocate each ivar in the dictionary right after its ivar header. *) : }STATIC 133 ?pairs ['] } >body ! \ restore old action for "}" false -> static? ; : STATIC{ ?class \ must be compiling a class ['] } >body @ \ save old action for "}" ['] }static -> } \ "}" will now be same as }static 133 \ for ?pairs true -> static? ; : STATIC gobble{ static{ ; \ =================================================== (* CL1 is our first stage cleanup word - called on an abort. Resets things to normal. Later cleanup words do their special stuff, then call CL1. Actually on the PPC it's not quite the first, since we've loaded pFiles already, and so have already introduced clFiles as the file cleanup word. On the 68k it was really the first. *) : CL1 (;cl) clrComp ['] (}) -> } 0 -> bufPtr 0 -> hiCDP \ for interpreting message binds resetTemps false -> rec? false -> union? false -> 68k_align? false -> compinline? false -> bind_to_reg? 0 -> extraFind 0 -> bufPtr false -> case_in_names? clFiles ; ' cl1 -> abortVec torture? not [IF] endload [THEN] (* *********** \ A simple test of the basic class stuff - run if the plot \ gets totally lost: :class nothingClass super{ object } ;class :class testClass super{ object } :m aa: 1 2 3 ;m :m bb: 99 aa: self ;m ;class testClass ttt bb: ttt \ should leave ( -- 1 2 3 99 ) :class cl2 super{ testClass } testClass bloggs :m cc: $ 1234 bb: bloggs bb: super ;m ;class cl2 myObj cc: myObj ********** *) \ =============================================================== \ TORTURE TESTS \ =============================================================== : ?CHK 2dup <> IF cr .h cr .h true abort" check FAILED!!!" \ error if something doesn't \ give what we expect ELSE 2drop THEN ; \ working on new temp object stuff here: (* ***** *) :class VAR super{ object } can_be_gpr 4 bytes data :m CLEAR: inline{ 0 ^base !} ;m :m GET: inline{ ^base @} ;m :m PUT: inline{ ^base !} ;m :m +: inline{ ^base @ + ^base !} ;m :m ->: inline{ @ ^base !} ;m :m classinit: db 123 ^base ! ;m ;class :class INT super{ object } can_be_gpr 2 bytes data :m CLEAR: inline{ 0 ^base w!} ;m :m GET: inline{ ^base w@} ;m :m PUT: inline{ ^base w!} ;m :m +: inline{ ^base w@ + ^base w!} ;m :m ->: inline{ w@ ^base w!} ;m :m classinit: db 123 ^base ! ;m ;class :class BYTE super{ object } can_be_gpr 1 bytes data :m CLEAR: inline{ 0 ^base c!} ;m :m GET: inline{ ^base c@x} ;m :m UGET: inline{ ^base c@} ;m :m PUT: inline{ ^base c!} ;m :m ->: inline{ c@ ^base c!} ;m :m PRINT: ^base c@ . ;m :m CLASSINIT: 9 put: self ;m ;class :class BOOL super{ byte } can_be_gpr :m GET: inline{ ^base c@x} ;m :m PUT: inline{ 0<> ^base c!} ;m :m SET: inline{ true ^base c!} ;m :m PRINT: get: self IF ." true" ELSE ." false" THEN ;m :m CLASSINIT: clear: self ;m ;class :class FLOAT super{ object } can_be_fpr 3 alignment 8 bytes data :m GET: \ ( -- x ) Pushes private data onto FP stack inline{ ^base f@} ;m :m PUT: \ ( x -- ) Stores float into private data inline{ ^base f!} ;m :m ->: \ ( float -- ) Assigns value of passed-in Float to this Float inline{ f@ ^base f!} ;m \ Normal arithmetic operations take a float on the FP stack. \ Methods starting with by obj_ take a Float object address. \ Methods ending with ->: take 2 Float object addresses and \ store the result in this object. :m +: inline{ ^base f@ f+ ^base f!} ;m :m obj_+: inline{ f@ ^base f@ f+ ^base f!} ;m :m +->: inline{ f@ f@ f+ ^base f!} ;m :m -: inline{ ^base f@ fswap f- ^base f!} ;m :m obj_-: inline{ ^base f@ f@ f- ^base f!} ;m :m -->: inline{ f@ f@ fswap f- ^base f!} ;m :m *: inline{ ^base f@ f* ^base f!} ;m :m obj_*: inline{ f@ ^base f@ f* ^base f!} ;m :m *->: inline{ f@ f@ f* ^base f!} ;m :m /: inline{ ^base f@ fswap f/ ^base f!} ;m :m obj_/: inline{ ^base f@ f@ f/ ^base f!} ;m :m /->: inline{ f@ f@ fswap f/ ^base f!} ;m :m test: ^base 8 dump ;m ;class : __v3op hex intrp1 intrp1 decimal false (vop) ; immediate : __v2op postpone tuck postpone __v3op ; immediate : __v4op hex intrp1 intrp1 decimal true (vop) ; immediate :class WORD_VECTOR super{ object } can_be_vr 4 alignment 16 bytes data :m +: inline{ ^base __v2op 21 2 } ;m :m +->: inline{ ^base __v3op 21 2 } ;m :m -: inline{ ^base __v2op 22 2 } ;m :m -->: inline{ ^base __v3op 22 2 } ;m :m and: inline{ ^base __v2op 23 0 } ;m :m or: inline{ ^base __v2op 24 0 } ;m :m xor: inline{ ^base __v2op 25 0 } ;m :m and->: inline{ ^base __v3op 23 0 } ;m :m or->: inline{ ^base __v3op 24 0 } ;m :m xor->: inline{ ^base __v3op 25 0 } ;m :m ->: inline{ dup ^base __v3op 24 2 } ;m :m splat: inline{ ^base __v3op 80 2 } ;m :m Nsplat: inline{ dup ^base __v3op 81 2 } ;m :m select: inline{ ^base __v4op 90 0 } ;m :m permute: inline{ ^base __v4op 91 0 } ;m :m AT: ( index -- n ) 4* ^base + @ ;m :m TO: ( n index -- ) 4* ^base + ! ;m :m GET: \ ( -- n1..n4 ) 4 0 DO ^base i 4* + @ LOOP ;m :m PUT: \ ( n1..n4 -- ) 4 FOR ^base i 4* + ! NEXT ;m :m classinit: 4 FOR i ^base i 4* + ! NEXT ;m ;class :class UWORD_VECTOR super{ word_vector } can_be_vr 4 alignment :m +: inline{ ^base __v2op 21 42 } ;m :m +->: inline{ ^base __v3op 21 42 } ;m :m -: inline{ ^base __v2op 22 42 } ;m :m -->: inline{ ^base __v3op 22 42 } ;m ;class :class SWORD_VECTOR super{ word_vector } can_be_vr 4 alignment :m +: inline{ ^base __v2op 21 C2 } ;m :m +->: inline{ ^base __v3op 21 C2 } ;m :m -: inline{ ^base __v2op 22 C2 } ;m :m -->: inline{ ^base __v3op 22 C2 } ;m :m Nsplat: inline{ dup ^base __v3op 81 C2 } ;m ;class :class INT_VECTOR super{ word_vector } can_be_vr 4 alignment :m PUT: \ ( n1..n16 -- ) 8 FOR ^base i 2* + w! NEXT ;m :m +: inline{ ^base __v2op 21 1 } ;m :m +->: inline{ ^base __v3op 21 1 } ;m :m -: inline{ ^base __v2op 22 1 } ;m :m -->: inline{ ^base __v3op 22 1 } ;m :m ->: inline{ dup ^base __v3op 24 1 } ;m :m splat: inline{ ^base __v3op 80 1 } ;m :m Nsplat: inline{ dup ^base __v3op 81 1 } ;m :m classinit: 4 FOR i ^base i 4* + ! NEXT ;m ;class :class UINT_VECTOR super{ int_vector } can_be_vr 4 alignment :m +: inline{ ^base __v2op 21 41 } ;m :m +->: inline{ ^base __v3op 21 41 } ;m :m -: inline{ ^base __v2op 22 41 } ;m :m -->: inline{ ^base __v3op 22 41 } ;m :m *: inline{ ^base __v2op 12 41 } ;m :m *h: inline{ ^base __v2op 10 41 } ;m :m *->: inline{ ^base __v3op 12 41 } ;m :m *h->: inline{ ^base __v3op 10 41 } ;m ;class :class SINT_VECTOR super{ word_vector } can_be_vr 4 alignment :m +: inline{ ^base __v2op 21 C2 } ;m :m +->: inline{ ^base __v3op 21 C2 } ;m :m -: inline{ ^base __v2op 22 C2 } ;m :m -->: inline{ ^base __v3op 22 C2 } ;m :m *: inline{ ^base __v2op 12 C1 } ;m :m *h: inline{ ^base __v2op 10 C1 } ;m :m *->: inline{ ^base __v3op 12 C1 } ;m :m *h->: inline{ ^base __v3op 10 C1 } ;m :m Nsplat: inline{ dup ^base __v3op 81 C1 } ;m ;class :class BYTE_VECTOR super{ word_vector } can_be_vr 4 alignment :m PUT: \ ( n1..n16 -- ) 16 FOR ^base i + c! NEXT ;m :m +: inline{ ^base __v2op 21 0 } ;m :m +->: inline{ ^base __v3op 21 0 } ;m \ 2 operand vectors :m -: inline{ ^base __v2op 22 0 } ;m :m -->: inline{ ^base __v3op 22 0 } ;m \ 2 operand vectors :m ->: inline{ dup ^base __v3op 24 0 } ;m :m splat: inline{ ^base __v3op 80 0 } ;m :m Nsplat: inline{ dup ^base __v3op 81 0 } ;m :m classinit: 16 FOR i ^base i 2* + w! NEXT ;m ;class :class UBYTE_VECTOR super{ byte_vector } can_be_vr 4 alignment :m +: inline{ ^base __v2op 21 40 } ;m :m +->: inline{ ^base __v3op 21 40 } ;m :m -: inline{ ^base __v2op 22 40 } ;m :m -->: inline{ ^base __v3op 22 40 } ;m :m *: inline{ ^base __v2op 12 40 } ;m :m *h: inline{ ^base __v2op 10 40 } ;m :m *->: inline{ ^base __v3op 12 40 } ;m :m *h->: inline{ ^base __v3op 10 40 } ;m ;class :class SBYTE_VECTOR super{ byte_vector } can_be_vr 4 alignment :m +: inline{ ^base __v2op 21 C0 } ;m :m +->: inline{ ^base __v3op 21 C0 } ;m :m -: inline{ ^base __v2op 22 C0 } ;m :m -->: inline{ ^base __v3op 22 C0 } ;m :m *: inline{ ^base __v2op 12 C0 } ;m :m *h: inline{ ^base __v2op 10 C0 } ;m :m *->: inline{ ^base __v3op 12 C0 } ;m :m *h->: inline{ ^base __v3op 10 C0 } ;m :m Nsplat: inline{ dup ^base __v3op 81 C0 } ;m ;class :class FLOAT_VECTOR super{ object } can_be_vr 4 alignment 16 bytes data :m +: inline{ ^base __v2op 41 3 } ;m :m +->: inline{ ^base __v3op 41 3 } ;m :m -: inline{ ^base __v2op 48 3 } ;m :m -->: inline{ ^base __v3op 48 3 } ;m :m *+: inline{ ^base dup __v4op 43 3 } ;m :m *+->: inline{ ^base __v4op 43 3 } ;m :m ->: inline{ dup ^base __v3op 24 2 } ;m :m select: inline{ ^base __v4op 90 0 } ;m :m permute: inline{ ^base __v4op 91 0 } ;m :m AT: ( index -- n ) 4* ^base + sf@ ;m :m TO: ( n index -- ) 4* ^base + sf! ;m :m GET: \ ( -- n1..n4 ) 4 0 DO ^base i 4* + sf@ LOOP ;m :m PUT: \ ( n1..n4 -- ) 4 FOR ^base i 4* + sf! NEXT ;m ;class +echo int_vector vv3 int_vector vv4 : q { \ %aa %bb -- } temp{ register byte_vector vb1 register sbyte_vector vb2 register ubyte_vector vb3 register sbyte_vector vb4 register int_vector vi1 register sint_vector vi2 register uint_vector vi3 register uword_vector uvw1 register sword_vector vw1 register sword_vector vw2 register float_vector fv1 register float_vector fv2 register float_vector fv3 register float f1 register float f2 register float f3 } vb2 -: vb1 f2 obj_-: f1 f2 f3 -->: f1 5 Nsplat: uvw1 -3 Nsplat: vi2 vi1 2 splat: vi3 vb1 10 splat: vb2 vb1 vb2 vb3 permute: vb4 fv1 fv2 *+: fv3 ; : qq db q ; endload ***** *) :class VAR super{ object } 4 bytes data :m CLEAR: inline{ 0 ^base !} ;m :m GET: inline{ ^base @} ;m :m PUT: inline{ ^base !} ;m :m GETT: ^base @ ;m :m PUTT: ^base ! ;m :m +: inline{ ^base +!} ;m :m -: inline{ ^base -!} ;m :m ->: inline{ @ ^base !} ;m :m TEST: @ ^base ! ;m mlocal LOCTEST: { aa \ bb cc -- } :m AAA: aa -> bb ;m :mloc LOCTEST: \ should double the number passed in and store in self aaa: self \ ." loctest: here!" cr bb -> cc bb ++> cc cc ^base ! ;mloc mlocal LOCTEST2: { aa bb cc dd ee ff \ gg hh ii -- } :m bbb: aa bb + cc * -> gg dd ee + ff * -> hh gg hh + -> ii " hi there" ;m :mloc loctest2: bbb: self ii ^base ! " ho ho" ;mloc :m PRINT: ^base @ . ;m :m CLASSINIT: $ 123 put: self ;m ;class :class BYTE super{ object } 1 bytes data :m CLEAR: inline{ 0 ^base c!} ;m :m GET: inline{ ^base c@x} ;m :m UGET: inline{ ^base c@} ;m :m PUT: inline{ ^base c!} ;m :m ->: inline{ c@ ^base c!} ;m :m PRINT: ^base c@ . ;m :m CLASSINIT: 9 put: self ;m ;class \ some very simple testing, to start with: 0 value testVal var aVar byte aByte : test1 ." test1" cr 987 avar ! get: avar 987 ?chk \ optimizes addr: avar -> testVal 876 testVal ! \ should clobber opt get: avar 876 ?chk ; : test2 \ testing late binding - assumes test1 done ." test2" cr get: [ avar ] 876 ?chk \ now, does the late-bind cache work? get: [ avar ] 876 ?chk ; local localTest { \ aa bb cc dd -- } : aaa " hahaha" ; :loc localTest aaa " hoho" ;loc : test3 \ testing local methods, and local sections with const \ data. Note: we can assume ordinary local sections \ work, since we use them in the class stuff so we wouldn't \ have made it to here unless they work!! ." test3" cr 222 loctest: aVar get: aVar 444 ?chk 20 30 3 \ -> 150 10 30 4 \ -> 160 loctest2: aVar get: aVar 310 ?chk " ho ho" s= -1 ?chk " hi there" s= -1 ?chk localtest " hoho" s= -1 ?chk " hahaha" s= -1 ?chk ; var vv :class BOOL super{ byte } :m GET: inline{ ^base c@x} ;m :m PUT: inline{ 0<> ^base c!} ;m :m SET: inline{ true ^base c!} ;m :m PRINT: get: self IF ." true" ELSE ." false" THEN ;m :m CLASSINIT: clear: self ;m ;class :class BARRAY super{ object } 1 indexed :m AT: \ ( index -- n ) inline{ ^elem c@} ;m :m TO: \ ( n index -- ) inline{ ^elem c!} ;m :m ^ELEM: \ ( index -- addr ) inline{ ^elem} ;m :m FILL: \ ( value -- ) Fills all elements with value. idxbase limit 2* bounds ?DO dup i c! LOOP drop ;m :m WIDTH: 1 ;m \ Faster than the default in Object :m GETELEM: \ ( addr -- n ) Fetches one element at addr c@x ;m :m TEST: at: self ;m ;class \ Testing arrays: 20 barray bb : test4 ." test4" cr $ 9887 bb 20 + c! 12 -> testVal testVal test: bb $ 87 ?chk 120 -> testVal \ ." should fail range check and trap - just step past the tw:" cr cr \ testval test: bb \ range check now omitted since Jasik doesn't \ like it. Try it after we've loaded our \ exception handler in zObjInit. ; \ also we test indexed classes which are subclassed and have \ added ivars, to make sure we get the right offset to the \ indexed header: :class INDEXED-OBJ super{ object } :m ^ELEM: ^elem ;m :m LIMIT: limit ;m :m WIDTH: idxbase 6 - w@ ;m :m IXADDR: idxbase ;m :m CLEARX: \ Erases indexed area. idxbase limit width: self * erase ;m :m CLASSINIT: clearX: self ;m ;class :class WARRAY super{ indexed-obj } 2 indexed :m AT: \ ( index -- n ) inline{ ^elem w@x} ;m :m ATT: ^elem w@x ;m :m TO: \ ( n index -- ) inline{ ^elem w!} ;m ;class :class TRIGTABLE super{ wArray } 3 wArray AXISVALS ;class 10 trigtable ttt $ 56 ttt $ 26 + w! : test5 { \ xx -- } ." test5" cr addr: ttt -> xx \ so we can look at it in the debugger 3 at: ttt $ 56 ?chk ; \ Testing object pointers var vv1 objPtr ov class_is var objPtr ov1 class_is var objPtr ob class_is bool : test6 ." test6" cr $ 765 put: vv $ 543 put: vv1 vv1 -> ov1 vv -> ov gett: ov1 $ 543 ?chk get: ov $ 765 ?chk $ 345 putt: ov get: ov $ 345 ?chk ; \ Testing static and public ivars :class SIVTEST super{ var } public static { var V1 bool B1 byte B2 10 barray BB } bool BLOC var VLOC :m QQ: get: v1 get: b1 get: b2 4 at: bb get: vloc ;m :m TEST: 66 put: v1 77 put: vloc ;m :m CLASSINIT: 32 put: v1 set: b1 33 put: b2 34 4 to: bb set: bloc 34 put: vloc ;m ;class sivtest zzz sivtest sss objPtr myop class_is sivtest : QQQ \ classinit: zzz classinit: sss \ needed in qpClass, but not here get: ivar> v1 in_class sivtest test: sss get: ivar> b2 in_class sivtest get: ivar> v1 in_class sivtest zzz get: ivar> bloc in class_as> sivtest sss get: ivar> vloc in class_as> sivtest ; : test7 ." test7" cr qqq 77 ?chk -1 ?chk 66 ?chk 33 ?chk 32 ?chk ; :class HAHA super{ object } sivtest IVsss :m QQ: test: IVsss get: ivar> vloc IN ivsss ;m ;class haha hh : test8 ." test8" cr classinit: zzz qq: hh 77 ?chk get: ivar> vloc IN zzz 34 ?chk ; \ Testing late bind to self :class VAR+ super{ var } :m QQ: get: [self] \ should make class general get: [ self ] \ shouldn't give any error ;m ;class var+ VVV \ qq: vvv \ no need for ?chk since it will give its own error : test9 ." test9" cr qq: vvv 2drop ; \ Testing records and unions. Also, the TEST: method piles up so many \ values that this also tests register spilling with a duplicate value! :class RECTEST super{ object } var vv record RR { var v1 bool b1 3 barray bbb byte b3 \ now aligned - unions should normally \ start out aligned, but we don't insist \ on it union { byte b2 var v2 record { byte bb1 byte bb2 } } var v3 } :m TEST: 4 0 to: bbb 5 1 to: bbb 6 2 to: bbb $ 33 put: vv $ 123 put: v1 set: b1 $ 124 put: v2 7 put: b3 $ 35 put: bb1 $ 36 put: bb2 $ 125 put: v3 $ 37 put: b2 get: v1 put: b1 get: b2 get: v2 get: bb1 get: bb2 get: v3 addr: rr 36 + @ ;m ;class recTest rrr : test10 ." test10" cr $ 33 addr: vvv ! qq: vvv $ 33 ?chk $ 33 ?chk test: rrr $ 125 ?chk $ 125 ?chk $ 36 ?chk $ 37 ?chk $ 37360124 ?chk $ 37 ?chk rrr $ 2C + @ $ 04050607 ?chk ; \ testing multiple inheritance :class INT super{ object } 2 bytes data :m CLEAR: inline{ 0 ^base ! } ;m :m UGET: inline{ ^base w@ } ;m :m GET: inline{ ^base w@x } ;m :m PUT: inline{ obj w! } ;m :m PUTT: ^base w! ;m :m IPUT: ^base w! ;m \ used in testing mult inheritance :m CLASSINIT: $ 456 put: self ;m ;class :class CC super{ byte int var bool } :m TEST: iput: self \ check it compiles uget: self \ offs should be 0 +: self \ offs should be 4 set: self ;m \ offs should be E :m TEST1: set: self get: super> bool \ should get -1 get: super ;m :m setValues: 9 put: super> byte $ 456 putt: super \ should go to the int $ 456 put: super> int $ 123 put: super> var set: super ;m ;class cc myCC : test11 { \ addr -- } ." test11" cr addr: mycc -> addr setValues: mycc mycc @ $ 09000000 ?chk mycc 4+ @ $ fff40002 ?chk mycc 8 + @ $ 04560000 ?chk mycc 12 + @ $ ffec0002 ?chk mycc 16 + @ $ 123 ?chk mycc 20 + @ $ ffe40002 ?chk mycc 24 + @ $ ff000000 ?chk ; :class STRANGE super{ object } var VV byte BB :m GET: get: vv get: bb ;m :m PUT: put: bb put: vv ;m ;class :class ARRAY super{ indexed-obj } 4 indexed :m AT: \ ( index -- n ) inline{ ^elem @} ;m :m ATT: ^elem @ ;m :m TO: \ ( n index -- ) inline{ ^elem !} ;m :m +TO: \ ( n index -- ) inline{ ^elem +!} ;m :m -TO: \ ( n index -- ) inline{ ^elem -!} ;m :m FILL: \ ( value -- ) Fills all elements with value. idxbase limit 4* bounds DO dup i ! 4 +LOOP drop ;m :m ATEST: 1 at: self ;m ;class :class MULT super{ var int array } :m MTEST: $ 456 put: super> int $ 123 put: super> var uget: super 999 1 to: self ;m :m MAT: at: self ;m ;class objPtr OO class_is mult objPtr OOO class_is int :class IVXX super{ object } 10 bytes data2 int i1 int i2 130 bytes qqqq \ Include to check >128 distance \ index addressing of array qwert 9 array qwert :m ITEST: $ 8456 dup i1 w! addr: i2 w! \ should be equivalent get: i1 uget: i2 66 put: i2 99 3 to: qwert 1234 drop 3 at: qwert addr: i2 -> ooo ;m :m GETQWERT: addr: qwert ;m ;class int ii 3 mult mm ivxx iv : test12 ." test12" cr itest: iv $ 63 ?chk $ 8456 ?chk $ ffff8456 ?chk mtest: mm $ 456 ?chk 88 iput: mm \ Note: get: mm will bind to the var, but uget: mm \ will bind to the int and give 88. get: mm $ 123 ?chk uget: mm 88 ?chk ; : test13 ." test13" cr itest: iv getqwert: iv 3 swap at: ** 99 ?chk mtest: mm $ 456 ?chk 1 at: mm 999 ?chk 1 mat: mm 999 ?chk 1 mm at: mult 999 ?chk 1 mm at: [] 999 ?chk mm -> oo 1 at: oo 999 ?chk 1 mat: oo 999 ?chk uget: mm $ 456 ?chk addr: mm addr: oo ?chk \ Both numbers shd be same uget: ooo 66 ?chk ; \ testing ivSetup (via deep_classinit: ) - this should put the $123 and \ $456 in the var and the int, and store the same offsets in the header \ that are already there. :class ivsTestClass super{ var int array } record { var v1 int i1 byte b1 3 array a1 } ;class 5 ivsTestClass ivs1 : test14 { \ aa -- } ." test14" cr deep_classinit: ivs1 addr: ivs1 @ $ 123 ?chk addr: ivs1 4 + @ $ FFF4003A ?chk addr: ivs1 8 + @ $ 04560000 ?chk addr: ivs1 12 + @ $ FFEC0032 ?chk addr: ivs1 16 + @ $ 123 ?chk addr: ivs1 20 + @ $ 04560900 ?chk addr: ivs1 24 + @ $ 0 ?chk \ array has no name so zero here addr: ivs1 -> aa addr: ivs1 28 + c@ $ 08 ?chk \ rest of reloc addr can change addr: ivs1 32 + @ $ FFFC000A ?chk addr: ivs1 36 + @ $ 4 ?chk addr: ivs1 40 + @ $ 2 ?chk ; \ Testing temp objects :class strxx super{ string } :m RELEASE: ." string released" cr release: super ;m ;class : leaf ; : test15 { \ aa bb -- } temp { var v1 var v2 strxx s1 } ." test15" cr ." locreg value:" locreg . cr get: v1 get: v2 $ 123 ?chk $ 123 ?chk leaf " hello world!" put: s1 ." The next line should say hello world!" cr get: s1 type cr ." The next line should say string released" cr ; :class AAAA super{ object } :m CLICK: { \ part ^ctl action1 action2 x y -- } null ;m ;class aaaa myAAAA : test16 ." test16" cr click: myAAAA ; \ =========== TORTURE runs the test! ============ : TORTURE ." torture tests start..." cr cr test1 test2 test3 test4 test5 test6 test7 test8 test9 test10 test11 test12 test13 test14 test15 test16 cr cr ." torture tests WORKED!!!" cr ;